(FILECREATED "15-APR-74 03:31:56" CYCLIC2)


  (LISPXPRINT (QUOTE CYCLIC2VARS)
	      T)
  (RPAQQ CYCLIC2VARS
	 ((FNS FVPARTITIONS FVPARTITION1 FVPART1)
	  (FNS LOOPPARTITIONS LOOPPARTITIONS1 LPROWS CLPARTLP1 CLPARTITIONSL 
	       NEWNODES NEWNODES1 GRAPHON MINLOOPS MAXLOOPS ROWS)
	  (FNS SUPERATOMPARTITIONS MAXUNSATL)))
(DEFINEQ

(FVPARTITIONS
(LAMBDA (FV VL) (for FVP in (FVPARTITION1 FV (CDR VL) 1) bind FVR eachtime
(SETQ FVR (ROWS FVP)) collect (create FVPARTITION NEWVL ← (for ROW in FVR
as COL in (CONS NIL FVP) as V in VL collect (IPLUS V (SUMOF ROW) (IMINUS (SUMOF
COL)))) FVR ← FVR))))

(FVPARTITION1
(LAMBDA (N VL S) (* Partition N into as many parts as length VL; with the
Ith part having at most VL:I* (S+I) - Then partition the ith part according
to FVPART1) (COND ((NULL VL) (LIST NIL)) (T (bind ((MAXI← (IMIN N (ITIMES
(CAR VL) S)))) for I from (IMAX 0 (IDIFFERENCE N (TD (CDR VL) (ADD1 S))))
to MAXI eachtime (SETQ PARTREST (FVPARTITION1 (IDIFFERENCE N I) (CDR VL) (ADD1
S))) join (for FIRSTPART in (FVPART1 I (CAR VL) S) join (for RESTPART in 
PARTREST rcollect (CONS FIRSTPART RESTPART))))))))

(FVPART1
(LAMBDA (N MAXSUM MAXOCCUR) (* Partition N into parts of the form MAXOCCUR
* I1 , MAXOCCUR-1 * I2 , MAXOCCUR-2 * I3 ... where the SUM of the I's is less
than or equal to MAXSUM) (* WARNING: value may be RPLAC'ed) (COND ((ZEROP
MAXOCCUR) (LIST NIL)) ((ZEROP N) (LIST (LISTOF MAXOCCUR 0))) (T (for I from
(MAX 0 (IDIFFERENCE N (ITIMES MAXSUM (SUB1 MAXOCCUR)))) bind ((MAXI← (MIN
MAXSUM (IQUOTIENT N MAXOCCUR)))) to MAXI join (for REST in (FVPART1 (IDIFFERENCE
N (ITIMES I MAXOCCUR)) (IDIFFERENCE MAXSUM I) (SUB1 MAXOCCUR)) rcollect (CONS
I REST)))))))
)
(DEFINEQ

(LOOPPARTITIONS
(LAMBDA (NLOOPS VLIST) (* Returns a list of lists of LOOPPARTITIONs, sorted
by NEWVL, for NLOOPS loops among the valence list VL; a LOOPPARTITION consists
of a NEW.VALENCE.LIST (new valence list) , EDGELABELS (a composition list
of number-of-bivalents) , and LOOPLABELS (a composition list of loop-types,
where a loop-type is a composition list of number-of-bivalents) %. For example,
the looplabels: ((((5 . 2) (3 . 2)) . 1) (((1 . 2)) . 3)) means that 1 node
gets two loops with 5 bivalents and two loops with 3; and that three nodes
get two loops with 1 bivalent (e.g. O=X=O)) (* LOOPPARTITIONS1 determines
where the loops will go; LOOP.ARRAY.ROWS is a list ROWS:2 ROWS:3 ROWS:4 ...
, where ROWS:i is a list: ((number of i valent nodes with no loops) (number
of i valent nodes getting 1 loop) (number of i valent nodes getting 2 loops)
...) where the valence refers to the valence in the NEW graph) (for LPP in
(LOOPPARTITIONS1 NLOOPS (CDDR VLIST) 4) bind LPROWS NEWVLIST when (GRAPHON
(TRIMZEROS (SETQ NEWVLIST (CONS (SUMOF (CDAR (SETQ LPROWS (LPROWS LPP VLIST))))
(for X in (CDR LPROWS) collect (SUMOF X)))))) rcollect (for NBIVEDGES from
0 to MAXI bind ((MAXI← (MIN (IDIFFERENCE (CAR VLIST) NLOOPS) (IQUOTIENT (TD
NEWVLIST 2) 2)))) join (for BIVPART in (NUMPARTITIONS (CAR VLIST) (IPLUS NLOOPS
NBIVEDGES) 1 NIL) bind BIVPARTCL eachtime (SETQ BIVPARTCL (CLCREATE BIVPART))
join (for BIVEDGES in (CLPARTS BIVPARTCL NBIVEDGES) join (for LOOP.BIVALENTS
in (CLPARTITIONSL (CLDIFF BIVPARTCL BIVEDGES) (TRIMNILS (CDRLIST LPROWS)))
rcollect (create LOOPPARTITION LOOPVL ← NEWVLIST EDGELABELS ← BIVEDGES 
LOOPLABELS ← LOOP.BIVALENTS))))))))

(LOOPPARTITIONS1
(LAMBDA (P VL J) (* P is a number of loops; VL is a valencelist starting with
J-valents; returns the partitions of number of loops among these nodes - a
partition is of the form (j-valentpart j+1-valentpart ...) where each part
is (number of single loops, number of double loops, ...)) (COND ((NULL VL)
(LIST NIL)) (T (* PJ is the number of loops allocated to J-valents; MAXREST
is the max number of loops that can go on the rest) (for PJ from (IMAX 0 (
IDIFFERENCE P (MAXREST (CDR VL) (ADD1 J)))) to MAXI bind ((MAXI← (IMIN P (ITIMES
(SUB1 (IQUOTIENT J 2)) (CAR VL))))) bind RESTL eachtime (SETQ RESTL (
LOOPPARTITIONS1 (IDIFFERENCE P PJ) (CDR VL) (ADD1 J))) join (for THISPART1
in (FVPART1 PJ (CAR VL) (SUB1 (IQUOTIENT J 2))) bind THISPART eachtime (SETQ
THISPART (TRIMZEROS (DREVERSE THISPART1))) join (for RESTPART in RESTL rcollect
(CONS THISPART RESTPART))))))))

(LPROWS
(LAMBDA (LPP VL) (* VL is a valencelist starting with bivalents - LPP is an
output from LOOPPARTITIONS1: LPP:i+2 corresponds to VL:i, and is the list
(number of single loops, number of double loops, ... for the i-valent nodes))
(SETQ VL (CONS (CAR VL) (CONS (CADR VL) (for V2 in (CDDR VL) as LOOPLST in
LPP collect (IDIFFERENCE V2 (SUMOF LOOPLST)))))) (* This VL is now the valence
list with the looped nodes removed) (for V in VL collect (CONS V (NEWNODES
(PROG1 LPP (SETQ LPP (CDR LPP))))))))

(CLPARTLP1
(LAMBDA (CL ROW N) (COND ((NULL ROW) (LIST NIL)) ((ZEROP (CAR ROW)) (CLPARTLP1
CL (CDR ROW) (ADD1 N))) (T (for EP in (CLPARTS CL (ITIMES N (CAR ROW))) bind
RPL eachtime (SETQ RPL (CLPARTLP1 (CLDIFF CL EP) (CDR ROW) (ADD1 N))) join
(for EEP in (CLEQUALPARTS EP (CAR ROW) N) join (for RP in RPL collect (NCONC
(CLCREATE EEP) RP))))))))

(CLPARTITIONSL
(LAMBDA (CL LL) (* This function does much of the work of LOOPPARTITIONS -
CL is a compositionlist of bivalents; LL is a list (l:2 l:3 l:4 ...) where
l:i is the list (number of single loops, number of double loops , ...) for
the i-valents; this function returns the list of possible ways of distributing
those bivalents among those loops) (COND ((NULL LL) (LIST NIL)) (T (PROG (
RESULTS RESTPARTLIST) (for FIRSTPART in (CLPARTS CL (TD (CAR LL) 1)) do (*
(TD L:I 1) is the number of total loops on the i-valents) (SETQ RESTPARTLIST
(CLPARTITIONSL (CLDIFF CL FIRSTPART) (CDR LL))) (* Take away the ones going
to the i-valent loops) (for THISPART in (CLPARTLP1 FIRSTPART (CAR LL) 1) do
(* CLPARTLP1 partitions FIRSTPART among the single-loops, double-loops as
specified in (CAR LL)) (for RP in RESTPARTLIST do (SETQ RESULTS (CONS (CONS
THISPART RP) RESULTS))))) (RETURN RESULTS))))))

(NEWNODES
(LAMBDA (LPP) (* LPP is a list: LPP:i-2 is a list for the old i+VALENCE nodes
of the (number of single loops, number of double loops, ...) ; this function
returns (number of VALENCE+2 nodes getting 1 loop, number of VALENCE+4 nodes
getting 2 loops, ...)) (NEWNODES1 LPP 1)))

(NEWNODES1
(LAMBDA (LPP J) (COND ((NULL LPP) NIL) (T (PROG ((TEM (NEWNODES1 (CDDR LPP)
(ADD1 J))) (TEM2 (CAR (NTH (CAR LPP) J)))) (COND ((AND (NULL TEM) (OR (NULL
TEM2) (ZEROP TEM2))) NIL) (T (CONS (OR TEM2 0) TEM))))))))

(GRAPHON
(LAMBDA (VL) (SETQ VL (TRIMZEROS VL)) (AND (EVENP (TD VL 2)) (NOT (IGREATERP
(ITIMES 2 (MAXDEG VL 2)) (TD VL 2))))))

(MINLOOPS
(LAMBDA (VALENCELIST) (SETQ VALENCELIST (TRIMZEROS VALENCELIST)) (* Same as
- max { 0 , w2+ (2M (W) -TD (W)) /2⎇) (MAX 0 (IPLUS 1 (LENGTH VALENCELIST)
(IQUOTIENT (TD (CDR VALENCELIST) 3) -2)))))

(MAXLOOPS
(LAMBDA (VALENCELIST) (MIN (CAR VALENCELIST) (MAXREST (CDDR VALENCELIST) 4))))

(ROWS
(LAMBDA (LL) (COND ((NULL LL) (QUOTE (NIL))) (T (CONS (CARLIST LL) (ROWS (
CDRLIST (CDR LL))))))))
)
(DEFINEQ

(SUPERATOMPARTITIONS
(LAMBDA (CL U) (PROG (CL1 SZ MXUI VI) (SETQ CL1 (for PR in CL when (EQ (VALENCE
(CAR PR)) 1) collect PR)) (SETQ CL (CLDIFF CL CL1)) (SETQ SZ (CLCOUNT CL))
(RETURN (for PARTSIZE from 2 to SZ join (for VHAT in (CLPARTS CL PARTSIZE)
bind REMATS eachtime (SETQ REMATS (APPEND CL1 (CLDIFF CL VHAT))) join (for
#PARTS from (IQUOTIENT PARTSIZE 2) to 1 by -1 join (for PARTITION in (
CLPARTITIONSN VHAT #PARTS 2) bind VI MXUI eachtime (PROGN (SETQ VI (CLCREATE
PARTITION)) (SETQ MXUI (MAXUNSATL VI (COND ((AND (NULL REMATS) (NULL (CDR
PARTITION))) U))))) join (for UI in (NUMPARTITIONS' U 1 MXUI (collect CDR
in VI)) rcollect (create SUPERATOMPARTITION SUPERATOMPARTS ← (CLCREATE (collect
(CONS Y X) for X in (CLEXPAND VI) as Y in UI)) REMAININGATOMS ← REMATS))))))))))

(MAXUNSATL
(LAMBDA (PC U) (* Note U is either NIL (normal) or it is equal to the 
unsaturation in the case where remats is NIL and there is only one part here)
(for PARTNUM in PC collect (PROG (N TD M) (SETQ N (SETQ TD (SETQ M 0))) (for
PR in (CAR PARTNUM) do (SETQ N (IPLUS N (CDR PR))) (SETQ TD (IPLUS TD (ITIMES
(CDR PR) (VALENCE (CAR PR))))) (SETQ M (MAX M (VALENCE (CAR PR))))) (SETQ
N (IDIFFERENCE (IPLUS 2 TD) (ITIMES 2 N))) (RETURN (IQUOTIENT (IPLUS N (MIN
(COND ((AND U (EQ (ITIMES U 2) N)) 0) (T -1)) (IDIFFERENCE TD (ITIMES 2 M))))
2))))))
)
STOP